Linux Cubed Series 8: LINUX Games/Linux Cubed Series 8 - LINUX Games.iso/games/role/roleplay.0-s/roleplay/RolePlaying-1.0/scripts/CLFunctions

Text File | 1995-07-09 | 5KB | 224 lines

# Module: CLFunctions
# Tcl version: 7.3 (Tcl/Tk/XF)
# Tk version: 3.6
# XF version: $__lastrelease$
#

# module contents
global moduleList
global autoLoadList
set moduleList(CLFunctions) { CLBind CLDelete CLDelete1 CLGet CLFind CLInsert CLInsert1 CLMoveDown CLMoveUp CLNearest CLNearestTag CLSingleSelect CLSize}
set autoLoadList(CLFunctions) {1}

# procedures to show toplevel windows


# User defined procedures


# Procedure: CLBind
proc CLBind { canvas} {
  bind $canvas <B2-Motion> {%W scan dragto %x %y}
  bind $canvas <Button-2>  {%W scan mark %x %y}
  bind $canvas <Shift-B1-Motion> {
    set tag [CLNearestTag %W [%W canvasy %y]]
    if {$tag != {}} {%W select to $tag end}}
  bind $canvas <Shift-Button-1> {
    set tag [CLNearestTag %W [%W canvasy %y]]
    if {$tag != {}} {%W select adjust $tag end}}
  bind $canvas <B1-Motion> {
    set tag [CLNearestTag %W [%W canvasy %y]]
        if {$tag != {}} {%W select to $tag end}}
  bind $canvas <Button-1> {
    set tag [CLNearestTag %W [%W canvasy %y]]
    if {$tag != {}} {
      %W select from $tag 0
      %W select to $tag end
    }
      }
}


# Procedure: CLDelete
proc CLDelete { canvas first {last ""}} {
  if {$last == ""} {set last $first}
  while {$last >= $first} {
    CLDelete1 $canvas $first
    incr last -1
  }
}


# Procedure: CLDelete1
proc CLDelete1 { canvas first} {
  if {[$canvas find withtag CLE$first] != ""} {
    set bbox [$canvas bbox CLE$first]
    set height [expr [lindex $bbox 3] - [lindex $bbox 1]]
    $canvas delete CLE$first
    CLMoveUp $canvas [expr $first + 1] $height
  }
}


# Procedure: CLGet
proc CLGet { canvas index} {
  return [$canvas find withtag CLE$index]
}


# Procedure: CLFind
proc CLFind { canvas text} {
  set numElements [CLSize $canvas]
  for {set i 0} {$i < $numElements} {incr i} {
    set tags [CLGet $canvas $i]
    foreach t $tags {
      if {[$canvas type $t] == "text"} {
    if {[lindex [$canvas itemconfigure $t -text] 4] == $text} {
      return $i
    }
      }
    }
  }
}


# Procedure: CLInsert
proc CLInsert { canvas where args} {
  set numElements [CLSize $canvas]
  if {$where == "end"} {
    set where $numElements
  }
  if {[expr [llength $args] % 2] != 0} {
    error "wrong # args, should be CLInsert canvas where ?bm1 text1? ?bm2 text2? .frame8.frame4.frame0.frame1.frame1.."
  }
  set l [llength $args]
  for {set i 0} {$i < $l} {incr i 2} {
    set bm [lindex $args $i]
    set text [lindex $args [expr $i + 1]]
    CLInsert1 $canvas $where $bm $text
    incr where
  }
}


# Procedure: CLInsert1
proc CLInsert1 { canvas where bm text} {
  set numElements [CLSize $canvas]
  if {$where == "end"} {
    set where $numElements
  }
  set tag CLEnew
  set x 0
  $canvas create bitmap $x 0 -anchor nw -tag $tag -bitmap $bm
  set x [lindex [$canvas bbox $tag] 2]
  $canvas create text $x 0 -anchor nw -tag $tag -text $text
  set newbbox [$canvas bbox $tag]
  set itemheight [lindex $newbbox 3]
  set itemwidth  [lindex $newbbox 2]
  $canvas delete $tag
  if {$where < $numElements} {
    CLMoveDown $canvas $where $itemheight
  }
  set sr [lindex [$canvas configure -scrollregion] 4]
  if {$sr == {}} {set sr {0 0 0 0}}
  if {$itemwidth > [lindex $sr 2]} {
    set sr [lreplace $sr 2 2 $itemwidth]
  }
  set sr [lreplace $sr 3 3 [expr [lindex $sr 3] + $itemheight]]
  $canvas configure -scrollregion $sr
  set tag "CLE$where"
  set ypos 0
  if {$where != 0} {
    set prevtag "CLE[expr $where - 1]"
    set bbox [$canvas bbox $prevtag]
    set ypos [lindex $bbox 3]
  }
  set x 0
  $canvas create bitmap $x $ypos -anchor nw -tag $tag -bitmap $bm
  set x [expr [lindex [$canvas bbox $tag] 2] + 4]
  $canvas create text $x $ypos -anchor nw -tag $tag -text $text
}


# Procedure: CLMoveDown
proc CLMoveDown { canvas where h} {
  for {set i [CLSize $canvas]} {$i > $where} {incr i -1} {
    $canvas move CLE[expr $i - 1] 0 $h
    $canvas addtag CLE$i withtag CLE[expr $i -1]
    $canvas dtag CLE$i CLE[expr $i - 1]
  }
}


# Procedure: CLMoveUp
proc CLMoveUp { canvas where h} {
  set numElements [CLSize $canvas $where]
  for {set i $where} {$i < $numElements} {incr i} {
    $canvas move CLE$i 0 [expr 0 - $h]
    $canvas addtag CLE[expr $i - 1] withtag CLE$i
    $canvas dtag [expr $i - 1] CLE$i
  }
}


# Procedure: CLNearest
proc CLNearest { canvas y} {
  set item  [$canvas find closest 0 $y]
  set tags  [$canvas gettags $item]
  foreach t $tags {
    if {[string range $t 0 2] == "CLE"} {
      return [$canvas find withtag $t]
    }
  }
}


# Procedure: CLNearestTag
proc CLNearestTag { canvas y} {
  set item  [$canvas find closest 0 $y]
  set tags  [$canvas gettags $item]
  foreach t $tags {
    if {[string range $t 0 2] == "CLE"} {
      return $t
    }
  }
  return {}
}


# Procedure: CLSingleSelect
proc CLSingleSelect { canvas} {
  bind $canvas <Shift-B1-Motion> {
    set tag [CLNearestTag %W [%W canvasy %y]]
    if {$tag != {}} {
    %W select from $tag 0
    %W select to $tag end
    }}
  bind $canvas <Shift-Button-1> {
    set tag [CLNearestTag %W [%W canvasy %y]]
    if {$tag != {}} {
    %W select from $tag 0
    %W select to $tag end
    }}
  bind $canvas <B1-Motion> {
    set tag [CLNearestTag %W [%W canvasy %y]]
    if {$tag != {}} {
    %W select from $tag 0
    %W select to $tag end
    }}
}


# Procedure: CLSize
proc CLSize { canvas {start "0"}} {
  for {set i $start} {[$canvas gettags CLE$i] != ""} {incr i} {}
  return $i
}


# Internal procedures

# eof
#